home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
090
/
byte0487.arc
/
TELLO.ARC
/
PUZZLE.LSP
< prev
next >
Wrap
Text File
|
1980-01-01
|
3KB
|
130 lines
; PUZZLE
(defconstant size 511.)
(defconstant classmax 3.)
(defconstant typemax 12.)
(defconstant true t)
(defconstant false ())
(defvar iii 0)
(defvar kount 0)
(defvar *d* 8.)
(defvar piececount (make-array (1+ classmax) ':initial-element 0))
(defvar class (make-array (1+ typemax) ':initial-element 0))
(defvar piecemax (make-array (1+ typemax) ':initial-element 0))
(defvar puzzle (make-array (1+ size)))
(defvar *p* (make-array (list (1+ typemax) (1+ size))))
(defun fit (i j)
(let ((end (aref piecemax i)))
(do ((k 0 (1+ k)))
((> k end) true)
(cond ((aref *p* i k)
(cond ((aref puzzle (+ j k))
(return false))))))))
(defun place (i j)
(let ((end (aref piecemax i)))
(do ((k 0 (1+ k)))
((> k end))
(cond ((aref *p* i k)
(setf (aref puzzle (+ j k)) true))))
(setf (aref piececount (aref class i)) (- (aref piececount (aref class i)) 1))
(do ((k j (1+ k)))
((> k size)
; (terpri)
; (princ "Puzzle filled")
0)
(cond ((not (aref puzzle k))
(return k))))))
(defun puzzle-remove (i j)
(let ((end (aref piecemax i)))
(do ((k 0 (1+ k)))
((> k end))
(cond ((aref *p* i k) (setf (aref puzzle (+ j k)) false))))
(setf (aref piececount (aref class i)) (+ (aref piececount (aref class i)) 1))))
(defun trial (j)
(let ((k 0))
(do ((i 0 (1+ i)))
((> i typemax) (setq kount (1+ kount)) false)
(cond ((not (= (aref piececount (aref class i)) 0))
(cond ((fit i j)
(setq k (place i j))
(cond ((or (trial k)
(= k 0))
; (format t "~%Piece ~4D at ~4D." (+ i 1) (+ k 1))
(setq kount (+ kount 1))
(return true))
(t (puzzle-remove i j))))))))))
(defun definepiece (iclass ii jj kk)
(let ((index 0))
(do ((i 0 (1+ i)))
((> i ii))
(do ((j 0 (1+ j)))
((> j jj))
(do ((k 0 (1+ k)))
((> k kk))
(setq index (+ i (* *d* (+ j (* *d* k)))))
(setf (aref *p* iii index) true))))
(setf (aref class iii) iclass)
(setf (aref piecemax iii) index)
(cond ((not (= iii typemax))
(setq iii (+ iii 1))))))
(defun start ()
(do ((m 0 (1+ m)))
((> m size))
(setf (aref puzzle m) true))
(do ((i 1 (1+ i)))
((> i 5))
(do ((j 1 (1+ j)))
((> j 5))
(do ((k 1 (1+ k)))
((> k 5))
(setf (aref puzzle (+ i (* *d* (+ j (* *d* k))))) false))))
(do ((i 0 (1+ i)))
((> i typemax))
(do ((m 0 (1+ m)))
((> m size))
(setf (aref *p* i m) false)))
(setq iii 0)
(definePiece 0 3 1 0)
(definePiece 0 1 0 3)
(definePiece 0 0 3 1)
(definePiece 0 1 3 0)
(definePiece 0 3 0 1)
(definePiece 0 0 1 3)
(definePiece 1 2 0 0)
(definePiece 1 0 2 0)
(definePiece 1 0 0 2)
(definePiece 2 1 1 0)
(definePiece 2 1 0 1)
(definePiece 2 0 1 1)
(definePiece 3 1 1 1)
(setf (aref pieceCount 0) 13.)
(setf (aref pieceCount 1) 3)
(setf (aref pieceCount 2) 1)
(setf (aref pieceCount 3) 1)
(let ((m (+ 1 (* *d* (+ 1 *d*))))
(n 0)(kount 0))
(cond ((fit 0 m) (setq n (place 0 m)))
(t (format t "~%Error.")))
(cond ((trial n)
(format t "~%Success in ~4D trials." kount))
(t (format t "~%Failure.")))))
(define-timer puzzle "Puzzle" (start))
(qa-attempt "Puzzle" (start) nil)